PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/fielddh.exe/FIELDS_C.PAS

Pascal/Delphi Source File | 1992-04-30 | 25.2 KB | 685 lines

{*************************************************}
{                                                 }
{   Turbo Pascal 6.0                              }
{   Turbo Vision Forms Demo                       }
{   Copyright (c) 1990 by Borland International   }
{*************************************************}
{                                                 }
{  Original by BI, my additions are FREEWARE      }
{          Doug Hood CIS 70324,3336               }
{                                                 }
{*************************************************}
{ Original Allows for                             }
{   1: non-blank input lines!                     }
{   2: ranged integer fields!                     }
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{   DWH: added Err_Msg String                     }
{        added COLORS to buttons/static/input text}
{        added NoEcho fields (for passwords)      }
{        added UPPERCASE input lines              }
{        added centered input lines               }
{        added drive input lines                  }
{        added path  input lines                  }
{                                                 }
{*************************************************}

unit Fields_Color;

{$F+,O+,X+,S-,D-}

interface

uses Objects, Drivers, Dialogs, Views,
     Color_App;   {color Buttons/Text, dialogs, and field support}

type

{*************************************************************************}
{*  TInputLine (TVision)                                                 *}
{*        |                                                              *}
{*        + Color_InputLine (in unit COLOR_APP)                          *}
{*                |                                                      *}
{*                + TKeyInputLine (can be invalid if empty)              *}
{*                      |                                                *}
{*                      + TUpper_InputLine                               *}
{*                      |        |                                       *}
{*                      |        + TCentered_InputLine                   *}
{*                      |        |                                       *}
{*                      |        + TPath_InputLine                       *}
{*                      |        |                                       *}
{*                      |        + TDrive_InputLine                      *}
{*                      |        |                                       *}
{*                      |        + TNoEcho_InputLine                     *}
{*                      |        |                                       *}
{*                      |        + TDate_InputLine                       *}
{*                      |                                                *}
{*                      + TNumInputLine                                  *}
{*************************************************************************}


  {*------------------------------------------------*}
  { Same as Color_InputLine, except invalid if empty }
  {*------------------------------------------------*}
  PKeyInputLine = ^TKeyInputLine;
  TKeyInputLine = object(COLOR_APP.Color_InputLine)
    IsValid : boolean;
    Blank_Is_Allowed : boolean;
    constructor Init(var Bounds: TRect; AMaxLen: Integer;
                     Color_Id           : word;     {0=use default}
                     Empty_Allowed      : boolean);
    function Valid(Command: Word): Boolean; virtual;
    procedure HandleEvent (var Event : TEvent); virtual;
    function GetPalette: PPalette; VIRTUAL; {for change color on error}
  end; {tkeyinputline}


  {*-------------------------------------------------*}
  { Same as TKeyInputLine, except can force UPPERCASE }
  {*-------------------------------------------------*}
  PUpper_InputLine = ^TUpper_InputLine;
  TUpper_InputLine = object(TKeyInputLine)
    Force_UpperCase : boolean;
    constructor Init(var Bounds: TRect; AMaxLen: Integer;
                     Color_Id           : word;     {0=use default}
                     Empty_Allowed      : boolean;
                     Force_To_Uppercase : boolean);
    procedure HandleEvent (var Event : TEvent); virtual;
  end; {tupper_inputline}


  {*--------------------------------------------------------------*}
  { Same as TUpper_InputLine, except centers string as its entered }
  {*--------------------------------------------------------------*}
  PCentered_InputLine = ^TCentered_InputLine;
  TCentered_InputLine = object(TUpper_InputLine)
    Left_Justify_Allowed : boolean; {whether to look for ^LJ}
    constructor Init(var Bounds: TRect; AMaxLen: Integer;
                     Color_Id           : word;     {0=use default}
                     Empty_Allowed      : boolean;
                     Force_To_Uppercase : boolean;
                     Allow_Left_Justify : boolean); {^LJ}
    procedure HandleEvent (var Event : TEvent); virtual;
    procedure SetData(var Rec); virtual;
  end; {tcentered_inputline}


  {*--------------------------------------------------------------*}
  { Same as TUpper_InputLine, except expects full path syntax      }
  { also checks if path exists and warns user if it doesnt         }
  {*--------------------------------------------------------------*}
  PPath_InputLine = ^TPath_InputLine;
  TPath_InputLine = object(TUpper_InputLine)
    function Valid(Command: Word): Boolean; virtual;
  end; {tpath_inputline}


  {*--------------------------------------------------------------*}
  { Same as TUpper_InputLine, except expects a drive letter        }
  { also checks if drive exists and warns user if it doesnt        }
  {*--------------------------------------------------------------*}
  PDrive_InputLine = ^TDrive_InputLine;
  TDrive_InputLine = object(TUpper_InputLine)
    Bytes_Free_Req : LongInt;
    constructor Init(var Bounds: TRect; AMaxLen: Integer;
                     Color_Id                : word;     {0=use default}
                     Empty_Allowed           : boolean;
                     Force_To_Uppercase      : boolean;
                     Num_Disk_Bytes_Required : LongInt); {0=dont care}
    function Valid(Command: Word): Boolean; virtual;
  end; {tdrive_inputline}


  {*---------------------------------------------------*}
  { Same as TInputLine, except writes '*' for each char }
  {  [very useful for passwords]                        }
  {*---------------------------------------------------*}
  PNoEcho_InputLine = ^TNoEcho_InputLine;
  TNoEcho_InputLine = object(TUPPER_InputLine)
     procedure Draw; virtual;
  end; {tnoecho_inputline}


  {*----------------------------------------------------*}
  { Accepts only valid numeric input between Min and Max }
  {*----------------------------------------------------*}
  PNumInputLine = ^TNumInputLine;
  TNumInputLine = object (TKeyInputLine)
    Min: Longint;
    Max: Longint;
    Err_Msg_String : string[80];
    constructor Init(var Bounds: TRect; AMaxLen: Integer;
                     Color_Id           : word;     {0=use default}
                     Empty_Allowed      : boolean;
                     AMin, AMax: Longint;
                     Err_Msg_Start : string);
    constructor Load(var S: TStream);
    function DataSize: Word; virtual;
    procedure GetData(var Rec); virtual;
    procedure SetData(var Rec); virtual;
    procedure Store(var S: TStream);
    function Valid(Command: Word): Boolean; virtual;
  end; {tnuminputline}


  {*--------------------------------------------------------------*}
  { Same as TUpper_InputLine, except expects date syntax           }
  { also checks if date exists and warns user if it doesnt         }
  {*--------------------------------------------------------------*}
  PDate_InputLine = ^TDate_InputLine;
  TDate_InputLine = object(TUpper_InputLine)
    Month, Day, Year : word;
    function Valid(Command: Word): Boolean; virtual;
    constructor Init (var Bounds: TRect; AMaxLen: Integer;
                      Color_Id                : word;
                      Empty_Allowed           : boolean;
                      Force_To_UpperCase      : boolean;
                      Default_To_ToDay        : boolean);
  end; {tdate_inputline}

procedure RegisterFields;

const
  RKeyInputLine: TStreamRec = (
     ObjType: 10060;
     VmtLink: Ofs(TypeOf(TKeyInputLine)^);
     Load:    @TKeyInputLine.Load;
     Store:   @TKeyInputLine.Store
  );
  RNumInputLine: TStreamRec = (
     ObjType: 10061;
     VmtLink: Ofs(TypeOf(TNumInputLine)^);
     Load:    @TNumInputLine.Load;
     Store:   @TNumInputLine.Store
  );
  {*----------------------------------------------------------------*}
  {* NOTE: the new fields arent TStreamed, unless someone out there *}
  {*       wants to help????                                        *}
  {*----------------------------------------------------------------*}


{***********************************************************************}
{***********************************************************************}
{***********************************************************************}
implementation

uses MsgBox,
     Str_Stf,
     File_Lib,
     Dates,   {for date valid check}
     DOS;

{************************************************************************}
procedure RegisterFields;
begin
  RegisterType(RKeyInputLine);
  RegisterType(RNumInputLine);
end;

{ TKeyInputLine }
{************************************************************************}
function TKeyInputLine.Valid(Command: Word): Boolean;
begin
  IsValid := True;
  if ((Command <> cmCancel) and (Command <> cmValid) and
       (NOT Blank_Is_Allowed)) then
  begin
    if Data^ = '' then
    begin
      IsValid := False;
      Select;
      MessageBox('This field cannot be Empty.', nil, mfError + mfOkButton);
    end;
  end;
  if IsValid
    then Valid := TInputLine.Valid(Command)
    else Valid := FALSE;
end; {valid}

{************************************************************************}
procedure TKeyInputLine.HandleEvent (var Event : TEvent);
begin
  IsValid := TRUE;  {for no flash when leave field}
  Color_InputLine.HandleEvent (Event);
end; {handleevent}

{************************************************************************}
function TKeyInputLine.GetPalette: PPalette;
var
 AltPalette: String[Length(CInputLine)];
begin
     { By assigning a palette index number that is out of the range of
       our owner's palette, we automatically get flashing white on red
       for this color entry.}
  AltPalette := Color_InputLine.GetPalette^;
  if (NOT IsValid)
    then AltPalette[1] := #255;    {pos 1 is the PASSIVE color}
  GetPalette := @AltPalette;
end;



{************************************************************************}
constructor TKeyInputLine.Init (var Bounds: TRect; AMaxLen: Integer;
                                Color_Id           : word;
                                Empty_Allowed       : boolean);
begin
  Color_InputLine.Init (Bounds, AMaxLen, Color_Id);
  Blank_Is_Allowed := Empty_Allowed;
  IsValid := TRUE;{Valid(cmOk);}
end; {upper}

{************************************************************************}
constructor TUpper_InputLine.Init (var Bounds: TRect; AMaxLen: Integer;
                                    Color_Id           : word;
                                    Empty_Allowed      : boolean;
                                    Force_To_Uppercase : boolean);
begin
  TKeyInputLine.Init (Bounds, AMaxLen, Color_Id, Empty_Allowed);
  Force_UpperCase := Force_To_Uppercase;
end; {upper}

{***********************************************************************}
procedure TUpper_InputLine.HandleEvent(var Event: TEvent);
begin
  IF ((Force_UpperCase) and
      ((Event.What = evKeyDown) and
       (Event.CharCode in ['a'..'z'])))
    THEN Event.CharCode := CHR((ORD(Event.CharCode) - 32));

  TKeyInputLine.HandleEvent(Event);

end; {handleevent}


{************************************************************************}
constructor TCentered_InputLine.Init (var Bounds: TRect; AMaxLen: Integer;
                                     Color_Id           : word;
                                     Empty_Allowed      : boolean;
                                     Force_To_Uppercase : boolean;
                                     Allow_Left_Justify : boolean);
begin
  TUpper_InputLine.Init (Bounds, AMaxLen, Color_Id,
                        Empty_Allowed, Force_To_Uppercase);
  Left_Justify_Allowed := Allow_Left_Justify;
end; {centered}

{***********************************************************************}
procedure TCentered_InputLine.HandleEvent(var Event: TEvent);
var
  Center_Me        : boolean;
  Num_Trail_Blanks : integer;
  Temp_Str         : string;
  Temp_Pos         : integer;
begin
  {*----------------------------------------------------------------*}
  {* To speed things up, limit 'CENTERING' to be done only when     *}
  {* necessary.                                                     *}
  {*----------------------------------------------------------------*}
  IF ((Event.What = evKeyDown) and
          ((ORD(Event.CharCode) > 0) OR
           (Event.Command = kbBack) OR       {backspace}
           (Event.Command = kbDel)) )        {multi char delete}
    THEN Center_Me := TRUE
    ELSE Center_Me := FALSE;

  TUpper_InputLine.HandleEvent(Event);

  IF ((Center_Me) and (Left_Justify_Allowed)) THEN
    BEGIN
      Temp_Str := Trim_Leading_Only(Data^);
      IF ((LENGTH(Temp_Str) > 2) and (Temp_Str[1] = '^') and
          (Change_Case(Copy(Temp_Str,2,2)) = 'LJ')) THEN
        BEGIN
          Center_Me := FALSE;
          Data^ := Temp_Str;
          CurPos := LENGTH(Temp_Str);
          IF (CurPos > MaxLen)
            THEN CurPos := MaxLen;
        END;
    END; {if}

  IF (Center_Me) THEN
    BEGIN
      Temp_Str := Data^;
      Num_Trail_Blanks := LENGTH(Temp_Str);
      Temp_Str := Trim_Trailing_Only (Temp_Str);
      Num_Trail_Blanks := Num_Trail_Blanks - LENGTH (Temp_Str);

      Temp_Pos := CurPos;
      Temp_Str := Str_Stf.Trim_Trailing_Only (
                                   Str_Stf.Center_Str (Temp_Str, MaxLen));
      IF (Num_Trail_Blanks > 0) THEN
        BEGIN
          IF ((Num_Trail_Blanks + LENGTH (Temp_Str)) > MaxLen)
            THEN Num_Trail_Blanks := MaxLen - LENGTH (Temp_Str);
          IF (Num_Trail_Blanks > 0)
            THEN Temp_Str := Temp_Str + Fill_String (Num_Trail_Blanks, ' ');
        END; {if}

      IF (Data^ <> Temp_Str) THEN
        BEGIN
          IF (Temp_Pos > 0) THEN
            BEGIN  {* must recalculate position of curpos *}
              CurPos := Temp_Pos +
                  (LENGTH(Temp_Str) - LENGTH(Data^));
              IF (CurPos > MaxLen)
                THEN CurPos := MaxLen;
            END; {if}
          Data^ := Temp_Str;
          DrawView; {since now centered}
        END; {if}
    END; {if center_me}
end; {handleevent}

{************************************************************************}
procedure TCentered_InputLine.SetData(var Rec);
var
  Temp_Str : string;
  Do_It    : boolean;
begin
  IF (Left_Justify_Allowed) THEN
    BEGIN
      Temp_Str := TRIM(STRING(Rec));
      IF ((LENGTH(Temp_Str) > 2) and (Temp_Str[1] = '^') and
          (Change_Case(Copy(Temp_Str,2,2)) = 'LJ'))
        THEN Do_It := FALSE
        ELSE Do_It := TRUE;
    END
  ELSE Do_It := TRUE;

  IF (Do_It)
    THEN Data^ := Str_Stf.Trim_Trailing_Only(
                        Str_Stf.Center_Str (STRING(Rec), MaxLen))
    ELSE Data^ := STRING(Rec);
  SelectAll(True);
end; {setdata}


{************************************************************************}
{ TNumInputLine }
constructor TNumInputLine.Init(var Bounds: TRect; AMaxLen: Integer;
                               Color_Id           : word;
                               Empty_Allowed      : boolean;
                               AMin, AMax: Longint;
                               Err_Msg_Start : string);
begin
  TKeyInputLine.Init (Bounds, AMaxLen, Color_ID, Empty_Allowed);
  {TInputLine.Init (Bounds, AMaxLen);}
  Min := AMin;
  Max := AMax;
  Err_Msg_String := Str_Stf.Trim (Err_Msg_Start);
  IF (LENGTH(Err_Msg_String) = 0)
    THEN Err_Msg_String := 'Number';
end;

{************************************************************************}
constructor TNumInputLine.Load(var S: TStream);
begin
  Color_InputLine.Load(S);
  {TInputLine.Load(S);}
  S.Read(Min, SizeOf(LongInt) * 2);
end;

{************************************************************************}
function TNumInputLine.DataSize: Word;
begin
  DataSize := SizeOf(LongInt);
end;

{************************************************************************}
procedure TNumInputLine.GetData(var Rec);
var
  Code: Integer;
begin
  Val(Data^, Longint(Rec), Code);
end;

{************************************************************************}
procedure TNumInputLine.Store(var S: TStream);
begin
  Color_InputLine.Store(S);
  {TInputLine.Store(S);}
  S.Write(Min, SizeOf(Longint) * 2);
end;

{************************************************************************}
procedure TNumInputLine.SetData(var Rec);
var
  S: string[11];
begin
  Str(Longint(Rec), S);
  Data^ := S;
  SelectAll(True);
end;

{************************************************************************}
function TNumInputLine.Valid(Command: Word): Boolean;
var
  Code: Integer;
  Value: Longint;
  Params: array[0..1] of LongInt;
begin
  IsValid := True;
  if (Command <> cmCancel) and (Command <> cmValid) then
  begin
    if Data^ = '' then Data^ := '0';
    IsValid := TKeyInputLine.Valid(Command);
    if (IsValid) then
      begin
        Val (Data^, Value, Code);
        if ((Code <> 0) or (Value < Min) or (Value > Max)) then
          begin
            IsValid := False;
            Select;
            {SelectAll(True);}
            Params[0] := Min;
            Params[1] := Max;
            MSGBOX.MessageBox (Err_Msg_String+' must be from %D to %D.',
                              @Params, mfError + mfOkButton);
            {SelectAll(True);}
          end;
      end;
    end;
  Valid := IsValid;
end; {valid}


{************************************************************************}
procedure TNoEcho_InputLine.Draw;
var
  Org_Str : String;
  i       : integer;
begin
  IF (LENGTH(Data^) > 0) THEN
    BEGIN
      {GetMem (Org_Str, MaxLen + 1);       {DWH 01-06-92}
      Org_Str := Data^;
      Data^ := Fill_String (Length(Data^), '*');
      {FOR i := 1 to LENGTH (Data^)
        DO Data^[i] := '*';}
      TUpper_InputLine.Draw;
      {FreeMem (Data, MaxLen + 1);         {DWH 01-06-92}
      Data^ := Org_Str;
    END
  ELSE TUpper_InputLine.Draw;
end; {draw}

{************************************************************************}
function TPath_InputLine.Valid(Command: Word): Boolean;
var
  Reply     : word;
  Status    : integer;
  Temp_Str  : string;
begin
  IsValid := True;
  if (Command <> cmCancel) and (Command <> cmValid) then
  begin
    IsValid := TUpper_InputLine.Valid(Command);
    Temp_Str := TRIM (Data^);
    if ((IsValid) and NOT (Temp_Str = '')) then
      BEGIN
        FILE_LIB.Check_Valid_Path (Temp_Str, Status);
        IF (Status <> 0) THEN
          BEGIN
            IsValid := False;
            Select;
          END; {if}

        CASE Status OF        (*   -1  is a blank handled already *)
          -2 : MessageBox ('This PATH field must end with a "\"', nil,
                           mfError + mfOkButton);
          -3 : MessageBox ('This field must contain the DRIVE Letter.'+
                           '(ex: C:\) ', nil,
                            mfError + mfOkButton);
          -4 : MessageBox ('This field must contain at least one "\".'+
                           '(ex: C:\) ', nil,
                           mfError + mfOkButton);
          -5 : BEGIN
                 Reply := Messagebox
                                ('Path ('+Temp_Str+') not exist!'+
                                 #13'Want to Fix It?',nil,
                                 mfError+mfYesButton+MfNoButton);
                IF (Reply <> cmNo)
                  THEN IsValid := FALSE {to allow for change}
                  ELSE IsValid := TRUE;
              END; {-4}
        END; {case}
      END; {if}
  end;
  Valid := IsValid;
end; {valid}

{************************************************************************}
constructor TDrive_InputLine.Init (var Bounds: TRect; AMaxLen: Integer;
                                   Color_Id                : word;
                                   Empty_Allowed           : boolean;
                                   Force_To_Uppercase      : boolean;
                                   Num_Disk_Bytes_Required : LongInt);
begin
  TUpper_InputLine.Init (Bounds, AMaxLen, Color_Id,
                         Empty_Allowed, Force_To_Uppercase);
  Bytes_Free_Req := Num_Disk_Bytes_Required;
end; {init}

{************************************************************************}
function TDrive_InputLine.Valid(Command: Word): Boolean;
var
  Free_Space : LongInt;
  Reply      : word;
  Temp_Str   : string;
begin
  IsValid := True;
  if (Command <> cmCancel) and (Command <> cmValid) then
  begin
    IsValid := TUpper_InputLine.Valid(Command);
    Temp_Str := TRIM (Data^);
    if ((IsValid) and NOT (Temp_Str = '')) then
      BEGIN
        IF (LENGTH(Temp_Str) <> 1) THEN
          BEGIN
            IsValid := False;
            Select;
            MessageBox ('This field must contain only the DRIVE Letter.'+
                        '(ex: "C"   not "C:\") ', nil,
                        mfError + mfOkButton);
          END
        ELSE IF ((ORD(Temp_Str[1]) < 65) and
                 (ORD(Temp_Str[1]) > 90)) THEN
          BEGIN
            IsValid := False;
            Select;
            MessageBox ('This field must contain a DRIVE Letter.'+
                        '(ex: A..Z) ', nil,
                        mfError + mfOkButton);
          END
        ELSE
          BEGIN {* Looks ok, check if drive exists *}
            Free_Space := DOS.DiskFree (ORD(Temp_Str[1])-64);
            IF (Free_Space = -1) THEN
              BEGIN
                IF (Bytes_Free_Req <> 0) THEN
                  BEGIN
                    IsValid := False;
                    Select;
                    Messagebox ('DRIVE ('+Temp_Str+') not exist!',nil,
                                mfError+mfOkButton);
                  END
                ELSE
                  BEGIN
                    IsValid := False;
                    Select;
                    Reply := Messagebox
                                ('DRIVE ('+Temp_Str+') not exist!'+
                                 #13'Want to Fix It?',nil,
                                 mfError+mfYesButton+MfNoButton);
                    IF (Reply <> cmNo)
                      THEN IsValid := FALSE {to allow for change}
                      ELSE IsValid := TRUE;
                  END;
              END
            ELSE IF ((Bytes_Free_Req > 0) and
                     (Free_Space < Bytes_Free_Req)) THEN
              BEGIN
                IsValid := False;
                Select;
                Messagebox ('DRIVE '+Temp_Str+' has '+Int_To_Str(Free_Space)+
                            ' bytes free BUT '+Int_To_Str(Bytes_Free_Req)+
                            ' free bytes are required!',nil,
                            mfError+mfOkButton);
              END;
          END;
      END; {if}
  end;
  Valid := IsValid;
end; {valid}

{************************************************************************}
constructor TDate_InputLine.Init (var Bounds: TRect; AMaxLen: Integer;
                                  Color_Id                : word;
                                  Empty_Allowed           : boolean;
                                  Force_To_Uppercase      : boolean;
                                  Default_To_ToDay        : boolean);
begin
  TUpper_InputLine.Init (Bounds, AMaxLen, Color_Id,
                         Empty_Allowed, Force_To_Uppercase);
  IF (Default_To_Today)
    THEN Data^ := DATES.MDYR_Str (0,0,0);
  Year  := 0;
  Month := 0;
  Day   := 0;
end; {init}


{************************************************************************}
function TDate_InputLine.Valid(Command: Word): Boolean;
var
  Reply     : word;
  Status    : integer;
  Temp_Str  : string;
  Err_Str   : string;
begin
  IsValid := True;
  if (Command <> cmCancel) and (Command <> cmValid) then
  begin
    IsValid := TUpper_InputLine.Valid(Command);
    Temp_Str := TRIM (Data^);
    IF ((IsValid) and NOT (Temp_Str = '')) then
      BEGIN
        IsValid := DATES.ValidDate_Str (Temp_Str,
                                        Year,Month,Day,
                                        Err_Str);
        IF (IsValid)
          THEN Data^ := DATES.MDYR_Str (Year, Month, Day)
        ELSE MessageBox (Err_Str, nil, mfError + mfOkButton);
      END;
  end;

  IF (NOT IsValid)
    THEN Select;

  Valid := IsValid;
end; {valid}



end. {unit FIELDS_Color}